home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / import-export / locate-entity.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  4.1 KB  |  142 lines  |  [TEXT/CCL2]
  1. ;;; This file deals with entities in import / export lists
  2.  
  3. ;;; This resolves an entity with the export table of a
  4. ;;; module.  It returns either a group, the symbol 'error, or the symbol
  5. ;;; 'not-found.  When force-error? is true, signal an error when
  6. ;;; the module is not found & return 'error.
  7.  
  8. (define (locate-entity/export-table entity mod force-error?)
  9.   (let* ((name (entity-name entity))
  10.      (group (table-entry (module-export-table mod) name)))
  11.     (if (eq? group '#f)
  12.     (if force-error?
  13.         (begin (signal-entity-not-found name (module-name mod))
  14.            'error)
  15.       'not-found)
  16.     (let ((def (group-definition group)))
  17.       (cond ((is-type? 'entity-var entity)
  18.          group)
  19.         ((is-type? 'entity-con entity)
  20.          (cond ((algdata? def)
  21.             (strip-constructors group))
  22.                ((synonym? def)
  23.             (signal-synonym-needs-dots name (module-name mod))
  24.             'error)
  25.                (else
  26.             (signal-wrong-definition
  27.               "type constructor" name (module-name mod))
  28.             'error)))
  29.         ((is-type? 'entity-abbreviated entity)
  30.          (cond ((algdata? def)
  31.             (cond ((hidden-constructors? group)
  32.                    (when force-error?
  33.                     (signal-abstract-type name (module-name mod)))
  34.                    'not-found)
  35.                   (else
  36.                    group)))
  37.                ((or (class? def) (synonym? def))
  38.             group)
  39.                (else
  40.             (signal-wrong-definition
  41.               "class or datatype" name (module-name mod))
  42.             'error)))
  43.         ((is-type? 'entity-class entity)
  44.          (if (class? def)
  45.              (match-constituents group (entity-class-methods entity)
  46.                      entity "method")
  47.              (begin
  48.               (signal-wrong-definition "class" name (module-name mod))
  49.               'error)))
  50.         ((is-type? 'entity-datatype entity)
  51.          (if (algdata? def)
  52.              (match-constituents group
  53.                      (entity-datatype-constructors entity)
  54.                      entity "constructor")
  55.              (begin
  56.                (signal-wrong-definition
  57.             "data type" name (module-name mod))
  58.                'error)))
  59.         (else
  60.          (error "Bad entity ~s." entity))
  61.         )))))
  62.  
  63. (define (match-constituents group names entity what)
  64.   (check-duplicates names entity)
  65.   (dolist (n-d (cdr group))
  66.     (when (not (memq (tuple-2-1 n-d) names))
  67.       (signal-missing-constituent entity (tuple-2-1 n-d) what)))
  68.   (dolist (name names)
  69.     (when (not (assq name (cdr group)))
  70.       (signal-extra-constituent entity name what)))
  71.   group)
  72.  
  73.  
  74. ;;; The following routine locates an entity in the current module.
  75. ;;; It may return 'error, 'not-found, or a group.
  76.  
  77. (define (locate-entity entity)
  78.   (let* ((name (entity-name entity))
  79.      (def (resolve-toplevel-name name)))
  80.     (cond ((eq? def '#f)
  81.        'not-found)
  82.       ((is-type? 'entity-var entity)
  83.        (if (method-var? def)
  84.            (begin (signal-export-method-var name def)
  85.               'error)
  86.            (make-group name def)))
  87.       ((is-type? 'entity-con entity)
  88.        (cond ((algdata? def)
  89.           (make-group name def))
  90.          ((synonym? def)
  91.           (signal-synonym-needs-dots name *module-name*)
  92.           'error)
  93.          (else
  94.           (signal-wrong-definition
  95.             "type constructor" name *module-name*)
  96.           'error)))
  97.       ((is-type? 'entity-abbreviated entity)
  98.        (cond ((algdata? def)
  99.           (require-complete-algdata
  100.            (gather-algdata-group name def)))
  101.          ((synonym? def)
  102.           (make-group name def))
  103.          ((class? def)
  104.           (gather-class-group name def))
  105.          (else
  106.           (signal-wrong-definition
  107.             "type constructor or class" name *module-name*)
  108.           'error)))
  109.       ((is-type? 'entity-class entity)
  110.        (if (class? def)
  111.            (match-group-names
  112.          (gather-class-group name def)
  113.          (entity-class-methods entity)
  114.          entity
  115.          "method")
  116.            (begin
  117.          (signal-wrong-definition "class" name *module-name*)
  118.          'error)))
  119.       ((is-type? 'entity-datatype entity)
  120.        (if (algdata? def)
  121.            (match-group-names
  122.          (require-complete-algdata (gather-algdata-group name def))
  123.          (entity-datatype-constructors entity)
  124.          entity "constructor")
  125.            (begin
  126.          (signal-wrong-definition "data type" name *module-name*)
  127.          'error)))
  128.       (else
  129.        (error "Bad entity ~s." entity)))))
  130.  
  131. (define (require-complete-algdata group)
  132.   (if (hidden-constructors? group)
  133.       'not-found
  134.       group))
  135.  
  136. (define (match-group-names group names entity what)
  137.   (when (not (eq? group 'not-found))
  138.     (match-constituents group names entity what))
  139.   group)
  140.  
  141.  
  142.